;;;;;; lexer.scm - Scheme Lexical Analyzer module.    -*- Mode: Scheme -*-
;;;;;; Author: Erik Silkensen <silkense@colorado.edu>
;;;;;; Version: 31 May 2009

#lang scheme

(require "numbers.scm")

;;; See Ch. 4.2 of the Revised^6 Report on the Algorithmic Language Scheme for
;;; documentation of the lexical structure of Scheme: <http://www.r6rs.org>

;;; This module implements something of a mix between the lexical syntax of
;;; R^5RS and R^6RS Scheme - maybe best described as a subset of them both.

;;; This module provides a procedure ``read-token'' that fetches the next token 
;;; from a specified input port and returns it as a token object. Procedures for
;;; selecting the attribtues of a token object are also provided.

;;; In order for the line and column starting numbers for a token to be saved, 
;;; line counting must be enabled on the input port that the token is read from.
;;; This can be done with the port-count-lines! procedure. If line counting is
;;; not enabled, #f will be used as both the line and column number.

;;; A token will have one of the following names: IDENTIFIER, BOOLEAN, NUMBER,
;;; CHARACTER, STRING, LEFT-PAREN, RIGHT-PAREN, LEFT-BRACKET, RIGHT-BRACKET, 
;;; VECTOR, SINGLE-QUOTE, BACKQUOTE, COMMA, COMMA-AT, DOT.

(provide 
 read-token
 peek-token
 token?
 identifier-token?
 boolean-token?
 number-token?
 character-token?
 string-token?
 name-token
 value-token
 position-token)

(define (token? object)
  (and (list? object)
       (not (null? object))
       (eq? (car object) 'token)))

(define (identifier-token? token)
  (type-token? token 'IDENTIFIER))

(define (boolean-token? token)
  (type-token? token 'BOOLEAN))

(define (number-token? token)
  (type-token? token 'NUMBER))

(define (character-token? token)
  (type-token? token 'CHARACTER))

(define (string-token? token)
  (type-token? token 'STRING))

(define (type-token? token type)
  (and (token? token)
       (eq? (name-token token) type)))

(define (name-token token)
  (cadr token))

(define (value-token token)
  (caddr token))

(define (position-token token)
  (cadddr token))

(define (make-token name value position)
  (list 'token name value position))

(define *peek* '())

;; Returns the next token, or #f if there is no next token.
(define (read-token [in (current-input-port)])
  (let ((token (if (null? *peek*)
                   (<token> in)
                   *peek*)))
    (set! *peek* '())
    token))

;; Different from ``read-token'', this procedure can be called multiple times,
;; and will return the same token until the token stream is read.
(define (peek-token [in (current-input-port)])
  (let ((token (if (null? *peek*)
                   (read-token in)
                   *peek*)))
    (set! *peek* (if token token '()))
    token))

;;; In general, if a procedure is named in <brackets>, it attempts to match and
;;; return a token object. Others of the form match-<name> attempt to match 
;;; characters, but most likely do not create a token object.

;; The starting state for every token. #f is returned at the end of input, a 
;; token object is returned if possible, and an error is raised otherwise.
(define (<token> [in (current-input-port)])
  (let* ((next-loc (next-location in)) (next-char (peek-char in)))
    (cond ((eof-object? next-char) #f)
          ((char-whitespace? next-char)
           (begin (read-char in)
                  (<token> in)))
          ((char=? #\; next-char)
           (<line-comment> (list (read-char in)) next-loc in))
          ((char-identifier-initial? next-char)
           (<identifier> (list (read-char in)) next-loc in))
          ((char=? #\# next-char)
           (<sharp> (list (read-char in)) next-loc in))
          ((or (char-peculiar? next-char)
               (char-numeric? next-char))
           (<number> '() next-loc in))
          ((char=? #\" next-char)
           (<string> (list (read-char in)) next-loc in))
          ((char=? #\, next-char)
           (<comma> (list (read-char in)) next-loc in))
          ((char=? #\. next-char)
           (<dot> (list (read-char in)) next-loc in))
          (else
           (let ((next-char (read-char in)))
             (cond ((char=? #\( next-char)
                    (make-token 'LEFT-PAREN "(" next-loc))
                   ((char=? #\) next-char)
                    (make-token 'RIGHT-PAREN ")" next-loc))
                   ((char=? #\' next-char)
                    (make-token 'SINGLE-QUOTE "'" next-loc))
                   ((char=? #\` next-char)
                    (make-token 'BACKQUOTE "`" next-loc))
                   ((char=? #\[ next-char)
                    (make-token 'LEFT-BRACKET "[" next-loc))
                   ((char=? #\] next-char)
                    (make-token 'RIGHT-BRACKET "]" next-loc))
                   ((char=? #\{ next-char)
                    (make-token 'LEFT-BRACE "{" next-loc))
                   ((char=? #\} next-char)
                    (make-token 'RIGHT-BRACE "}" next-loc))
                   (else
                    (syntax-error next-loc next-char))))))))

;; A line comment begins with ``;'' and extends until the end of the line. 
;; This procedure assumes that the ``;'' has already been matched.
(define (<line-comment> chars location [in (current-input-port)])
  (read-line in)
  (<token> in))

;; A block comment begins with ``#|'' and extends until the next ``|#'' or the
;; end of input. This procedure assumes that the ``#|'' has already been 
;; matched.
(define (<block-comment> chars location [in (current-input-port)])
  (let ((next-char (peek-char in)))
    (cond ((eof-object? next-char)
           (<token> in))
          ((char=? #\| next-char)
           (let* ((chars (cons (read-char in) chars))
                  (next-char (peek-char in)))
             (if (char=? #\# next-char)
                 (begin (read-char in)
                        (<token> in))
                 (<block-comment> (cons (read-char in) chars) location in))))
          (else
           (<block-comment> (cons (read-char in) chars) location in)))))

;; An identifier begins with an identifier-initial and extends (with 
;; identifier-subsequent) until a delimiter. It is an error for an identifier 
;; not to be terminated by a delimiter (or the end of input). This procedure
;; assumes that an identifier-initial has already been matched.
(define (<identifier> chars location [in (current-input-port)])
  (let ((next-char (peek-char in)))
    (cond ((char-identifier-subsequent? next-char)
           (<identifier> (cons (read-char in) chars) location in))
          ((char-delimiter? next-char)
           (let ((value (list->string (reverse chars))))
             (make-token 'IDENTIFIER value location)))
          (else
           (syntax-error location (list->string (reverse chars)))))))

;; A sharp ``#'' is the starting state for several tokens. This procedure 
;; assumes that the sharp has already been matched, and then moves to the next 
;; state.
;; <sharp> --> <block-comment> | <vector> | <boolean> | <character> | <number>
;; It is an error if none of these next states are recognized.
(define (<sharp> chars location [in (current-input-port)])
  (let ((next-char (peek-char in)))
    (cond ((char=? #\| next-char)
           (<block-comment> (cons (read-char in) chars) location in))
          ((char=? #\( next-char)
           (<vector> (cons (read-char in) chars) location in))
          ((char-boolean? next-char)
           (<boolean> (cons (read-char in) chars) location in))
          ((char=? #\\ next-char)
           (<character> (cons (read-char in) chars) location in))
          ((or (char-radix? next-char)
               (char-exactness? next-char))
           (<number> chars location in)) 
          (else
           (syntax-error location (list->string (reverse chars)))))))

;; A vector ``#('' represents the start of a literal vector definition. This 
;; procedure assumes that the vector token has already been matched.
(define (<vector> chars location [in (current-input-port)])
  (make-token 'VECTOR "#(" location))

;; A boolean ``#t'' or ``#f'' represents a literal boolean value. This procedure
;; assumes that the boolean token has already been matched, and verifies that it
;; terminates with a delimiter. It is an error for a boolean not to do so.
(define (<boolean> chars location [in (current-input-port)])
  (let ((next-char (peek-char in)))
    (if (char-delimiter? next-char)
        (make-token 'BOOLEAN (list->string (reverse chars)) location)
        (syntax-error location (list->string (reverse chars))))))

;; A character has either the form ``#\<character>'' or ``#\<character name>''. 
;; This procedure assumes that the ``#\'' has already been matched, and verifies
;; that the rest of the token terminates with a delimiter. It is an error for a
;; character not to do so. 
(define (<character> chars location [in (current-input-port)])
  (let ((next-char (peek-char in)))
    (cond ((not (char? next-char))
           (syntax-error location (list->string (reverse chars))))
          ((char=? #\s (char-downcase next-char))
           (let ((chars (cons (read-char in) chars)))
             (if (char-delimiter? (peek-char in))
                 (make-token 'CHARACTER (list->string (reverse chars)) location)
                 (<character-name> chars (string->list "pace") location in))))
          ((char=? #\n (char-downcase next-char))
           (let ((chars (cons (read-char in) chars)))
             (if (char-delimiter? (peek-char in))
                 (make-token 'CHARACTER (list->string (reverse chars)) location)
                 (<character-name> chars (string->list "ewline") location in))))
          (else
           (let* ((value (list->string (reverse (cons (read-char in) chars))))
                  (next-char (peek-char in)))
             (if (char-delimiter? next-char)
                 (make-token 'CHARACTER value location)
                 (syntax-error location (list->string (reverse chars)))))))))

;; A character name is a special character constant (e.g. #\newline). This 
;; procedure assumes that the first character of the name has already been 
;; matched, matches until the match parameter is the null list, and then 
;; verifies that character name terminates with a delimiter. It is an error not
;; to do so.
(define (<character-name> chars match location [in (current-input-port)])
  (let loop ((chars chars) (match match))
    (let ((next-char (peek-char in)))
      (cond ((and (char-delimiter? next-char)
                  (null? match))
             (make-token 'CHARACTER (list->string (reverse chars)) location))
            ((and (not (null? match))
                  (char=? (char-downcase next-char) (car match)))
             (loop (cons (read-char in) chars) (cdr match)))
            (else (syntax-error location 
                                (list->string (reverse chars))))))))

;; A string is a sequence of characters (or escaped characters) terminating with
;; a ``"''. This procedure assumes that the opening ``"'' has already been 
;; matched. It is an error for a string not to terminate with a ``"''.
(define (<string> chars location [in (current-input-port)])
  (let ((next-char (peek-char in)))
    (cond ((eof-object? next-char)
           (syntax-error location (list->string (reverse chars))))
          ((char-string-element? next-char)
           (<string> (cons (read-char in) chars) location in))
          ((char=? #\\ next-char)
           (let ((this-char (read-char in))
                 (next-char (peek-char in)))
             (if (char-escape? next-char)
                 (let ((esc (char->escape (read-char in))))
                   (<string> (cons esc chars) location in))
                 (syntax-error location (list->string (reverse chars))))))
          ((char=? #\" next-char)
           (let* ((next-char (read-char in))
                  (value (list->string (cdr (reverse chars)))))
             (make-token 'STRING value location)))
          (else
           (syntax-error location (list->string (reverse chars)))))))

;; A number token is made up of prefix and complex subtokens. In general, this
;; procedure assumes that the start of a character has been detected, but not 
;; matched (i.e. consumed) - other than an initial ``#'' character.
(define (<number> chars location [in (current-input-port)])
  (let ((prefix (match-prefix chars in)))
    (if prefix
        (<complex> (car prefix) (cdr prefix) location in)
        (syntax-error location (list->string (reverse chars))))))

;; Attempts to match the prefix of a number. The return value is a pair where 
;; the first element is the list of characters so far matched, and the second 
;; element is a predicate function that returns whether or not a given character
;; is a valid digit for a number with the detected radix. This procedure assumes
;; that at most the initial ``#'' marking a radix or exactness has been matched.
(define (match-prefix chars [in (current-input-port)])
  (let ((radix (match-radix chars in)))
    (if (not radix)
        (let ((exactness (match-exactness chars in)))
          (if exactness
              (let ((chars (match-#-<R> match-radix exactness in)))
                (if chars
                    chars
                    (cons exactness char-numeric?)))
              (cons chars char-numeric?)))
        (let ((exactness (match-#-<R> match-exactness (car radix) in)))
          (if exactness
              (cons exactness (cdr radix))
              radix)))))

;; Attempts to match the radix of a number. The return value is a pair where the
;; first element is the list of characters so far matched, and the second 
;; element is a predicate function that returns whether or not a given character
;; is a valid digit for a number with the detected radix. If the radix is empty,
;; it is assumed to be decimal. If the radix is invalid, #f is returned. This 
;; procedure assumes that the ``#'' (if present) has already been matched. 
(define (match-radix chars [in (current-input-port)])
  (let ((next-char (peek-char in)))
    (if (char-radix? next-char)
        (cons (cons (read-char in) chars)
              (char-radix->digits? next-char))
        #f)))
              
;; Attempts to match the exactness of a number. If an invalid exactness is 
;; detected, #f is returned. This procedure assumes that the ``#'' has already
;; been matched.
(define (match-exactness chars [in (current-input-port)])
  (let ((next-char (peek-char in)))
    (if (char-exactness? next-char)
        (cons (read-char in) chars)
        #f)))

;; The complex portion of a number is documented in Ch. 4.2.1 of the R^6RS 
;; sepcification. Pred? should be a predicate procedure for testing whether or
;; not a given character is valid for the number being matched. We follow many
;; implementations in their choice to not follow the specification: a failed
;; match of a number will usually transfer to the <identifier> state.
(define (<complex> chars pred? location [in (current-input-port)])
  (let* ((sign (match-sign chars in))
        (next-char (peek-char in)))
    (if (char=? #\i (char-downcase next-char))
        (<i> sign location in)
        (let* ((ureal (match-ureal-+ pred? sign in))
               (next-char (peek-char in)))
          (cond ((not ureal)
                 (<identifier> sign location in))
                ((char-delimiter? next-char)
                 (make-token 'NUMBER (list->string (reverse ureal)) location))
                ((char=? #\@ next-char)
                 (<real> pred? (cons (read-char in) ureal) location in))
                ((char-sign? next-char)
                 (let* ((chars (cons (read-char in) ureal))
                        (digits (match-ureal-* pred? chars in)))
                   (<i> digits location in)))
                (else
                 (<i> ureal location in)))))))
         
;; Matches the imaginary ``i'' portion of a number, where the ``i'' is meant to
;; terminate the number. A move to the identifier state is possible.
(define (<i> chars location in)
  (let ((next-char (peek-char in)))
    (if (char=? #\i (char-downcase next-char))
        (let* ((chars (cons (read-char in) chars))
               (next-char (peek-char in)))
          (if (char-delimiter? next-char)
              (make-token 'NUMBER (list->string (reverse chars)) location)
              (<identifier> chars location in)))
        (<identifier> chars location in))))

;; Matches a real number. Pred? should be a predicate procedure for testing 
;; whether or not a given character is valid for the number being matched. This
;; procedure assumes that at most the first digit has already been matched. It
;; attempts to match a sign before transfering to the ureal state.
(define (<real> pred? chars location [in (current-input-port)])
  (<ureal> pred? (match-sign chars in) location in))

;; Matches an unsigned real number. Pred? should be a predicate procedure for
;; testing whether or not a given character is valid for the number being 
;; matched. This procedure assumes that at most the first digit has already been
;; matched.
(define (<ureal> pred? chars location [in (current-input-port)])
  (let* ((chars (match-uinteger-* pred? chars in))
         (next-char (peek-char in)))
    (cond ((char-delimiter? next-char)
           (make-token 'NUMBER (list->string (reverse chars)) location))
          ((char=? #\/ next-char)
           (<uinteger> pred? (cons (read-char in) chars) location in))
          ((and (char=? #\. next-char)     ; pred? must be char-numeric?
                (eq? pred? char-numeric?)) ; in order to move to <decimal>
           (<decimal> (cons (read-char in) chars) location in))
          ((and (char-exponent-marker? next-char)
                (eq? pred? char-numeric?))
           (<suffix> chars location in))
          (else
           (syntax-error location (list->string (reverse chars)))))))

;; Attempts to match an unsigned real number, requiring that at least one digit
;; is matched immediately. Pred? should be a predicate procedure for testing
;; whether or not a given character is valid for the number being matched. #f is
;; returned on error.
(define (match-ureal-+ pred? chars [in (current-input-port)])
  (match-ureal match-uinteger-+ pred? chars in))

;; Attempts to match an unsigned real number. Pred? should be a predicate
;; procedure for testing whether or not a given character is valid for the 
;; number being matched. #f is returned on error.
(define (match-ureal-* pred? chars [in (current-input-port)])
  (match-ureal match-uinteger-* pred? chars in))

;; Generic procedure that attempts to match an unsigned real number. Match 
;; should be a procedure to apply immediately to the chars. Pred? should be a 
;; procedure for testing whether or not a given character is valid for the 
;; number being matched. #f is returned on error.
(define (match-ureal match pred? chars [in (current-input-port)])
  (let* ((chars (match pred? chars in))
         (next-char (peek-char in)))
    (cond ((not chars)
           #f)
          ((char-delimiter? next-char)
           chars)
          ((char=? #\/ next-char)
           (match-uinteger-+ pred? (cons (read-char in) chars) in))
          ((and (char=? #\. next-char)
                (eq? pred? char-numeric?))
           (match-decimal (cons (read-char in) chars) in))
          ((and (char-exponent-marker? next-char)
                (eq? pred? char-numeric?))
           (match-suffix chars in))
          (else
           chars))))  

;; Matches an unsigned integer number. Pred? should be a predicate procedure for
;; testing whether or not a given character is valid for the number being
;; mached. It is an error for a number to not be terminated with a delimiter.
(define (<uinteger> pred? chars location [in (current-input-port)])
  (let* ((digits (match-uinteger-+ pred? chars in))
         (next-char (peek-char in)))
    (if digits
        (if (char-delimiter? next-char)
            (make-token 'NUMBER (list->string (reverse digits)) location)
            (syntax-error location (list->string (reverse digits))))
        (syntax-error location (list->string (reverse chars))))))

;; Attempts to match an unsigned integer number, requiring that at least one 
;; digit is matched immediately. Pred? should be a predicate procedure for 
;; testing whether or not a given character is valid for the number being 
;; matched. #f is returned on error.
(define (match-uinteger-+ pred? chars [in (current-input-port)])
  (let ((digits (match-+ pred? chars in)))
    (if digits
        digits
        #f)))

;; Attempts to match an unsigned integer number. Pred? should be a predicate
;; procedure for testing whether or not a given character is valid for the 
;; number being matched. 
(define (match-uinteger-* pred? chars [in (current-input-port)])
  (let ((digits (match-* pred? chars in)))
    (if digits
        digits
        chars)))

;; A decimal number has an optional fractional component and ends with an
;; optional exponent. This procedure assumes that at most the first character 
;; has been matched. It is an error for a decimal number to not terminate with a
;; delimiter.
(define (<decimal> chars location [in (current-input-port)])
  (let* ((digits (match-decimal chars in))
         (next-char (peek-char in)))
    (if (and digits
             (char-delimiter? next-char))
        (make-token 'NUMBER (list->string (reverse digits)) location)
        (syntax-error location (list->string (reverse chars))))))

;; Attempts to match a decimal number. #f may be returned on error. 
(define (match-decimal chars [in (current-input-port)])
  (if (= (length chars) 1)
      (match-suffix (match-uinteger-+ char-numeric? chars in) in)
      (match-suffix (match-uinteger-* char-numeric? chars in) in)))

;; Attempts to match a sign (``+'' or ``-''). The characters matched are 
;; returned whether or not a sign is actually matched (i.e. no #f).
(define (match-sign chars [in (current-input-port)])
  (let ((next-char (peek-char in)))
    (if (or (char=? #\+ next-char)
            (char=? #\- next-char))
        (cons (read-char in) chars)
        chars)))

;; The suffix is the end of a decimal number. It may consist of an exponent. It
;; is an error for a number to not be terminated with a delimiter. This 
;; procedure assumes that everything up until the start of the suffix has been 
;; matched.
(define (<suffix> chars location [in (current-input-port)])
  (let* ((digits (match-suffix chars in))
         (next-char (peek-char in)))
    (if (and digits
             (char-delimiter? next-char))
        (make-token 'NUMBER (list->string (reverse digits)) location)
        (syntax-error location (list->string (reverse chars))))))

;; Attempts to match the suffix of a decimal number. Because a suffix can be
;; be empty, the original matched chars are returned if it is empty 
;; (i.e. no #f). This procedure assumes that everything up until the start of 
;; the suffix has been matched.
(define (match-suffix chars [in (current-input-port)])
  (let ((next-char (peek-char in)))
    (cond ((char-delimiter? next-char)
           chars)
          ((char-exponent-marker? next-char)
           (begin (set! chars (cons (read-char in) chars))
                  (set! chars (match-sign chars in))
                  (set! chars (match-+ char-numeric? chars in))
                  (set! next-char (peek-char in))
                  chars))
          (else
           chars))))

;; A comma may either be itself a token, or combine with the ``@'' symbol to 
;; make the COMMENT-AT token. The comma token doesn't need to be explicitly 
;; terminated with a delimiter.
(define (<comma> chars location [in (current-input-port)])
  (let ((next-char (peek-char in)))
    (if (char=? #\@ next-char)
        (begin (read-char in)
               (make-token 'COMMA-AT ",@" location))
        (make-token 'COMMA "," location))))

;; A dot may itself be a token, or it might be the start of a decimal number, or
;; it might be the start of an identifier. It is an error for any of these 
;; tokens to not be terminated with a delimiter.
(define (<dot> chars location [in (current-input-port)])
  (let ((next-char (peek-char in)))
    (cond ((and (= (length chars) 1)
                (char-numeric? next-char))
           (<decimal> (cons (read-char in) chars) location in))
          ((char-identifier-subsequent? next-char)
           (<identifier> (cons (read-char in) chars) location in))
          ((char-delimiter? next-char)
           (make-token 'DOT "." location))
          (else
           (syntax-error location (list->string (reverse chars)))))))

;; A generic procedure that matches ``one or more'' characters satisfying the
;; predicate procedure ``pred?''. If no characters match, #f is returned.
(define (match-+ pred? chars [in (current-input-port)])
  (if (pred? (peek-char in))
      (match-* pred? (cons (read-char in) chars) in)
      #f))

;; A generic procedure that matches ``zero or more'' characters satisfying the
;; predicate procedure ``pred?''. If no characters match, chars is returned.
(define (match-* pred? chars [in (current-input-port)])
  (define (match chars)
    (if (pred? (peek-char in))
        (match (cons (read-char in) chars))
        chars))
  (match chars))

;; A generic procedure that matches an opening ``#' and then calls the specified
;; procedure <R> with the characters so far matched and the input port. If the
;; ``#'' match is unsuccessfull, #f is returned.
(define (match-#-<R> <R> chars [in (current-input-port)])
  (if (char=? #\# (peek-char in))
      (<R> (cons (read-char in) chars) in)
      #f))

(define (char-delimiter? char)
  (or (eof-object? char)
      (char-whitespace? char)
      (char=? #\( char)
      (char=? #\) char)
      (char=? #\[ char)
      (char=? #\] char)
      (char=? #\" char)
      (char=? #\; char)
      (char=? #\# char)))

(define (char-identifier-initial? char)
  (case char
    ((#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~) #t)
    (else (char-alphabetic? char))))

(define (char-identifier-subsequent? char)
  (or (char-identifier-initial? char)
      (char-numeric? char)
      (char=? #\+ char)
      (char=? #\- char)
      (char=? #\. char)
      (char=? #\@ char)))

(define (char-boolean? char)
  (let ((char (char-downcase char)))
    (or (char=? #\t char)
        (char=? #\f char))))

(define (char-string-element? char)
  (and (not (char=? #\" char))
       (not (char=? #\\ char))))

(define (char-peculiar? char)
  (char-sign? char))

(define (char-escape? char)
  (case (char-downcase char)
    ((#\b #\t #\n #\v #\r #\" #\\) #t)
    (else #f)))

(define (char->escape char)
  (case (char-downcase char)
    ((#\b) #\backspace)
    ((#\t) #\tab)
    ((#\n) #\newline)
    ((#\r) #\return)
    ((#\v) #\vtab)
    ((#\" #\\) char)
    (else #f)))

(define (syntax-error location near)
  (error "bad syntax on line"
         (car location)
         'near
         near))

(define (next-location [in (current-input-port)])
  (let-values (((line-number line-column position) 
                (port-next-location in)))
              (cons line-number line-column)))
